home *** CD-ROM | disk | FTP | other *** search
/ Just Call Me Internet / Just Call Me Internet.iso / prog / atari / m2 / cat3src / cat / quicksor.i < prev    next >
Text File  |  1997-10-26  |  9KB  |  364 lines
  1. IMPLEMENTATION MODULE QuickSort;
  2.  
  3. FROM SYSTEM IMPORT ADDRESS, LOC, ADR, ASSEMBLER;
  4.  
  5. FROM Storage IMPORT ALLOCATE, DEALLOCATE;
  6.  
  7. IMPORT Lists;
  8.  
  9. IMPORT Block;
  10.  
  11. (*$H+*)
  12.  
  13. TYPE    copyProc    = PROCEDURE ((* from: *)  ADDRESS, 
  14.                                  (* count: *) LONGCARD, 
  15.                                  (* to:   *)  ADDRESS);
  16.  
  17. VAR memCopy:    copyProc;
  18.  
  19. (*$L-*)
  20. PROCEDURE copyByte (from: ADDRESS; count: LONGCARD; to: ADDRESS);
  21. BEGIN
  22.   ASSEMBLER
  23.     MOVE.L  -(A3),A1
  24.     SUBA.W  #4,A3
  25.     MOVE.L  -(A3),A0
  26.     MOVE.B  (A0),(A1)
  27.   END;
  28. END copyByte;
  29.  
  30. PROCEDURE copyWord (from: ADDRESS; count: LONGCARD; to: ADDRESS);
  31. BEGIN
  32.   ASSEMBLER
  33.     MOVE.L  -(A3),A1
  34.     SUBA.W  #4,A3
  35.     MOVE.L  -(A3),A0
  36.     MOVE.W  (A0),(A1)
  37.   END;
  38. END copyWord;
  39.  
  40. PROCEDURE copyLong (from: ADDRESS; count: LONGCARD; to: ADDRESS);
  41. BEGIN
  42.   ASSEMBLER
  43.     MOVE.L  -(A3),A1
  44.     SUBA.W  #4,A3
  45.     MOVE.L  -(A3),A0
  46.     MOVE.L  (A0),(A1)
  47.   END;
  48. END copyLong;
  49.  
  50. PROCEDURE copy6 (from: ADDRESS; count: LONGCARD; to: ADDRESS);
  51. BEGIN
  52.   ASSEMBLER
  53.     MOVE.L  -(A3),A1
  54.     SUBA.W  #4,A3
  55.     MOVE.L  -(A3),A0
  56.     MOVE.L  (A0)+,(A1)+
  57.     MOVE.W  (A0),(A1)
  58.   END;
  59. END copy6;
  60.  
  61. PROCEDURE copyDLong (from: ADDRESS; count: LONGCARD; to: ADDRESS);
  62. BEGIN
  63.   ASSEMBLER
  64.     MOVE.L  -(A3),A1
  65.     SUBA.W  #4,A3
  66.     MOVE.L  -(A3),A0
  67.     MOVE.L  (A0)+,(A1)+
  68.     MOVE.L  (A0),(A1)
  69.   END;
  70. END copyDLong;
  71.  
  72. PROCEDURE copy10 (from: ADDRESS; count: LONGCARD; to: ADDRESS);
  73. BEGIN
  74.   ASSEMBLER
  75.     MOVE.L  -(A3),A1
  76.     SUBA.W  #4,A3
  77.     MOVE.L  -(A3),A0
  78.     MOVE.L  (A0)+,(A1)+
  79.     MOVE.L  (A0)+,(A1)+
  80.     MOVE.W  (A0),(A1)
  81.   END;
  82. END copy10;
  83.  
  84. PROCEDURE copy12 (from: ADDRESS; count: LONGCARD; to: ADDRESS);
  85. BEGIN
  86.   ASSEMBLER
  87.     MOVE.L  -(A3),A1
  88.     SUBA.W  #4,A3
  89.     MOVE.L  -(A3),A0
  90.     MOVE.L  (A0)+,(A1)+
  91.     MOVE.L  (A0)+,(A1)+
  92.     MOVE.L  (A0),(A1)
  93.   END;
  94. END copy12;
  95. (*$L=*)
  96.  
  97. VAR  breakJN: BOOLEAN;
  98.  
  99. PROCEDURE sortIt (low, high : LONGINT; VAR ptrelem : LONGARRAY OF LOC;
  100.                   comp : compProc; entrySize : LONGINT;
  101.                   break: breakProc): BOOLEAN;
  102.  
  103.   CONST   Limit = 20;   (* Ab Limit wird auf InsertSort umgeschaltet. *)
  104.   
  105.   VAR tmpBuf : ADDRESS;
  106.       valueBuf : ADDRESS;
  107.  
  108.     PROCEDURE getIdx (idx: LONGINT) : ADDRESS;
  109.     BEGIN
  110.       RETURN (ADR(ptrelem)+ADDRESS (idx*entrySize));
  111.     END getIdx;
  112.  
  113.     PROCEDURE assign (i, j: LONGINT);
  114.       (* ptrelem[i] := ptrelem [j] *)
  115.     BEGIN
  116.       Block.Copy (getIdx (j), entrySize, getIdx(i));
  117.     END assign; 
  118.     
  119.     PROCEDURE Push (i : LONGINT);
  120.     BEGIN
  121.       Block.Copy (getIdx (i), entrySize, tmpBuf);
  122.     END Push;
  123.     
  124.     PROCEDURE PushValue (i : LONGINT);
  125.     BEGIN
  126.       Block.Copy (getIdx (i), entrySize, valueBuf);
  127.     END PushValue;
  128.     
  129.     PROCEDURE Pop (j: LONGINT);
  130.     BEGIN
  131.       Block.Copy (tmpBuf, entrySize, getIdx (j));
  132.     END Pop;
  133.     
  134.     PROCEDURE Swap (i, j: LONGINT); 
  135.     BEGIN
  136.       Block.Copy (getIdx (i), entrySize, tmpBuf);
  137.       Block.Copy (getIdx (j), entrySize, getIdx(i));
  138.       Block.Copy (tmpBuf, entrySize, getIdx (j));
  139.     END Swap;
  140.  
  141.     PROCEDURE InsertSort (l, r : LONGINT);
  142.       VAR  i, j  : LONGINT;
  143.            b     : BOOLEAN;
  144.  
  145.     BEGIN
  146.       FOR i := (l + 1) TO r DO
  147.         Push (i);
  148.         j := i - 1;
  149.         b := comp (tmpBuf,getIdx(j));
  150.  
  151.         WHILE b DO
  152.           assign (j+1, j);
  153.           DEC (j);
  154.           b := (j >= l);
  155.  
  156.           IF b THEN
  157.             b := comp (tmpBuf, getIdx(j));
  158.           END;
  159.         END;
  160.         Pop (j+1);
  161.         (* ptrelem[j + 1] := a; *)
  162.       END;
  163.     END InsertSort;
  164.     
  165.     FORWARD ChooseSort (l, r : LONGINT);
  166.  
  167.     PROCEDURE QuickSort (l, r : LONGINT);
  168.       VAR i, j : LONGINT;
  169.           p    : ADDRESS;
  170.     BEGIN
  171.       i := l;
  172.       j := r;
  173.       PushValue ((l+r) DIV 2);
  174.       REPEAT
  175.         WHILE comp (getIdx(i), valueBuf) DO INC (i); END;
  176.         WHILE comp (valueBuf, getIdx(j)) DO DEC (j); END;
  177.         IF (i <= j) 
  178.         THEN
  179.           Swap (i, j);
  180.           INC (i);
  181.           DEC (j);
  182.         END;
  183.       UNTIL (i > j);
  184.       IF (l < j) THEN ChooseSort (l, j); END;
  185.       IF breakJN THEN RETURN END;
  186.       IF (i < r) THEN ChooseSort (i, r); END;
  187.     END QuickSort;
  188.  
  189.     PROCEDURE ChooseSort (l, r : LONGINT);
  190.     BEGIN
  191.       IF breakJN THEN RETURN END;
  192.       IF ((r - l) > Limit) THEN
  193.         QuickSort (l, r);
  194.         IF break() THEN 
  195.           breakJN := TRUE;
  196.           RETURN 
  197.         END;
  198.       ELSE
  199.         InsertSort (l, r);
  200.         IF break() THEN 
  201.           breakJN := TRUE;
  202.           RETURN 
  203.         END;
  204.       END;
  205.     END ChooseSort;
  206.  
  207.   BEGIN
  208.     ALLOCATE (tmpBuf, entrySize);
  209.     IF tmpBuf = NIL THEN RETURN FALSE END;
  210.     ALLOCATE (valueBuf, entrySize);
  211.     IF valueBuf = NIL THEN 
  212.       DEALLOCATE (tmpBuf, 0);
  213.       RETURN FALSE 
  214.     END;
  215.     breakJN := FALSE;
  216.     CASE entrySize OF
  217.        1    : memCopy := copyByte; |
  218.        2    : memCopy := copyWord; |
  219.        4    : memCopy := copyLong; |
  220.        6    : memCopy := copy6;    |
  221.        8    : memCopy := copyDLong; |
  222.        10   : memCopy := copy10; |
  223.        12   : memCopy := copy12; |
  224.     ELSE
  225.       memCopy := Block.Copy;
  226.     END;
  227.     ChooseSort (low, high);
  228.     DEALLOCATE (valueBuf, 0);
  229.     DEALLOCATE (tmpBuf, 0);
  230.     RETURN TRUE;
  231.   END sortIt;
  232.  
  233. (* Interne Prozedur fr SortFonts *)
  234. TYPE PCarrier = POINTER TO Carrier;
  235.      Carrier  = RECORD
  236.                   next, prev: PCarrier;
  237.                   data: ADDRESS
  238.                 END;
  239.      MList = RECORD
  240.                current: PCarrier;
  241.                root   : PCarrier;
  242.                user   : PCarrier
  243.              END;
  244.  
  245. PROCEDURE ZipSort (VAR list: MList; nodes: CARDINAL; 
  246.                    comp : compProc; break: breakProc);
  247. (* Achtung: Diese Prozedur geht direkt auf die internen Datenstrukturen
  248.  * von Lists drauf. 
  249.  *)
  250.   VAR
  251.     list1, list2: MList;
  252.     I           : CARDINAL;
  253.     result,last1: MList;
  254.  
  255. BEGIN
  256.   IF break() THEN 
  257.     breakJN := TRUE;
  258.     RETURN 
  259.   END;
  260.   
  261.   IF nodes<=1 THEN RETURN END; (* Eine Liste aus einem Element ist schon sortiert *)
  262.  
  263.   (* Liste in etwa gleich grože Teile aufteilen: *)
  264.   (* list1 erh„lt nodes DIV 2; list2 den rest *)
  265.   list1 := list;
  266.   list2 := list;
  267.   FOR I := 1 TO (nodes DIV 2) DO
  268.     last1 := list2;
  269.     list2.current := list2.current^.next
  270.   END;
  271.   last1.current^.next := NIL; (* Listen auseinanderschneiden *)
  272.   list2.root := list2.current;
  273.   (* List1 zurcksetzen *)
  274.   list1.current := list1.root;
  275.   (*WriteList (list1);
  276.     WriteList (list2); *)
  277.   (* list1 und list2 enthalten garantiert mindestens 1 Element *)
  278.   (* Einzellisten Sortieren *)
  279.   ZipSort (list1,nodes DIV 2, comp, break);
  280.   ZipSort (list2,nodes - (nodes DIV 2), comp, break);
  281.  
  282.   (* Jetzt kommts: *)
  283.   (* Erstes Listenelement festlegen: *)
  284.   (* Die folgende IF-Bedingung macht das selbe wie die Zeile
  285.    * >IF Strings.Compare (list2^.info.name, list1^.info.name)=Strings.less THEN
  286.    * Ist aber statistisch wesentlich schneller.
  287.    * Die IF-Bedingung ben”tigt sonst mehr Rechenzeit als alle anderen
  288.    * Befehle zusammen.
  289.    *)
  290.   IF comp(list2.current^.data, list1.current^.data)
  291.   THEN
  292.     list := list2;
  293.     list2.current := list2.current^.next;
  294.     list2.root := list2.current;
  295.   ELSE
  296.     list := list1; 
  297.     list1.current := list1.current^.next;
  298.     list1.root := list1.current;
  299.   END;
  300.  
  301.   LOOP
  302.     IF (list1.current=NIL) OR (list1.current=list1.root) OR (list1.current^.data=NIL) THEN
  303.       list.current^.next := list2.current; EXIT
  304.     END;
  305.     IF (list2.current=NIL) OR (list2.current=list2.root)OR (list2.current^.data=NIL) THEN
  306.       list.current^.next := list1.current; EXIT
  307.     END;
  308.     IF comp(list2.current^.data, list1.current^.data)
  309.     THEN
  310.       list.current^.next := list2.current; 
  311.       list2.current := list2.current^.next;
  312.     ELSE
  313.       list.current^.next := list1.current; 
  314.       list1.current := list1.current^.next;
  315.     END;
  316.     list.current := list.current^.next;
  317.   END;
  318. END ZipSort;
  319.  
  320.  
  321. (* Gc: *)
  322. PROCEDURE ListSort (list: Lists.List; comp : compProc; break: breakProc): BOOLEAN;
  323. (* Sortiert eine Liste mittels Zip-Sort (c) by Gerd Castan
  324.  *)
  325.   VAR prev, 
  326.       oRoot,
  327.       entry : PCarrier;
  328.       rList : MList;
  329. BEGIN
  330.   breakJN := FALSE;
  331.   Lists.ResetList (list);
  332.   rList := MList (list);
  333.   rList.current := rList.root^.next;
  334.   oRoot := rList.root;
  335.   rList.root := rList.current;
  336.   (* Liste als einfach verkettete Liste interpretieren und sortieren: *)
  337.   ZipSort (rList, Lists.NoOfEntries (list), comp, break);
  338.  
  339.   IF breakJN THEN RETURN FALSE; END;
  340.   
  341.   (* Zerst”rte Rckw„rtsverkettung restaurieren: *)
  342.   rList.current := rList.root^.next;
  343.   rList.root := oRoot;
  344.   rList.root^.next := rList.current;
  345.   prev := NIL;
  346.   entry := rList.current;
  347.   WHILE entry#NIL DO
  348.     entry^.prev := prev;
  349.     prev := entry;
  350.     entry := entry^.next
  351.   END;
  352.   list := Lists.List (rList);
  353.   RETURN TRUE;
  354. END ListSort;
  355.  
  356. PROCEDURE noBreak(): BOOLEAN;
  357. BEGIN
  358.   RETURN FALSE
  359. END noBreak;
  360.  
  361. BEGIN
  362.   memCopy := Block.Copy;
  363. END QuickSort.
  364.